Software Vault: The Gold Collection/Software Vault - The Gold Collection (American Databankers) (1993).ISO/cdr05/mswlogo3.zip/MSWLOGO.ZIP/EXAMPLES.ZIP/SOLITAIR

Text File | 1993-04-13 | 10KB | 537 lines

;
; Function:
;
; Solitair game
;
; To Run:
;
; Load "solitair
; Call SOLITAIRE
;
;;; Every * has an INT to get around a Mac Berkeley Logo bug!

TO ASKDIGIT
MAKE "ONTO LIST "PLAYONTO :CHAR
END

TO ASKPARSE :CHAR
IF EQUALP :CHAR "U [ASKU STOP]
IF MEMBERP LIST "PLAYONTO :CHAR :ONTO [ASKDIGIT STOP]
BELL
ASKPARSE RC
END

TO ASKSTACKS :LIST
IF EMPTYP :LIST [TYPE [FOR STACK] STOP]
IF EQUALP FIRST FIRST :LIST "PLAYTOP [ASKUP STOP]
SPBTYPE 0 LAST FIRST :LIST
TYPE "| |
ASKSTACKS BF :LIST
END

TO ASKU
IFELSE EQUALP FIRST LAST :ONTO "PLAYTOP ~
       [MAKE "ONTO LAST :ONTO] [BELL ASKPARSE RC]
END

TO ASKUP
TYPE [FOR STACK,]
SETCURSOR [4 21]
TYPE "OR
SPBTYPE 1 "U
TYPE [| FOR| UP.]
END

TO ASKWHICH
SETCURSOR [1 20]
TYPE [PLAY WHERE? |TYPE |]
ASKSTACKS :ONTO
ASKPARSE RC
SETCURSOR [1 20]
SPACES 37 PR []
SPACES 37 PR []
END

TO BELL
TONE 1500 6
SETEMPTY "DIGIT
END

TO BLACKTYPE :WORD
TYPE STANDOUT :WORD
END

TO CARDBEFOREP :A :B
IF EQUALP :A "A [OUTPUT EQUALP :B 2]
IF EQUALP :A 10 [OUTPUT EQUALP :B "J]
IF EQUALP :A "J [OUTPUT EQUALP :B "Q]
IF EQUALP :A "Q [OUTPUT EQUALP :B "K]
IF EQUALP :A "K [OUTPUT "FALSE]
IF NOT NUMBERP :B [OUTPUT "FALSE]
OUTPUT EQUALP :A :B-1
END

TO CARDDIS :CARD
IFELSE MEMBERP SUIT :CARD :REDS [REDTYPE :CARD] [BLACKTYPE :CARD]
TYPE "| |
END

TO CHEAT
SETCURSOR [1 22] SPACES 3
IF NOT EQUALP :DIGIT 8 [BELL STOP]
IF AND EMPTYP :HAND EMPTYP :PILE [BELL STOP]
LPUSH DEAL "PILE
DISPILE
DISHAND
SETEMPTY "DIGIT
END

TO CHECKBLACK :NUM
IF NOT MEMBERP SUIT FIRST :STACK :REDS [STOP]
IF CARDBEFOREP (RANK :CARD) (RANK FIRST :STACK) ~
   [PUSH (LIST "PLAYONTO :NUM) "ONTO]
END

TO CHECKEMPTY :NUM
IF EQUALP RANK :CARD "K [PUSH (LIST "PLAYONTO :NUM) "ONTO OUTPUT "TRUE]
OUTPUT "FALSE
END

TO CHECKFULL :NUM :STACK
IFELSE MEMBERP SUIT :CARD :REDS [CHECKRED :NUM] [CHECKBLACK :NUM]
END

TO CHECKONTO :NUM
IF :NUM = 0 [STOP]
IFELSE STACKEMPTYP SHOWN :NUM ~
       [IF CHECKEMPTY :NUM [STOP]] [CHECKFULL :NUM THING SHOWN :NUM]
CHECKONTO :NUM-1
END

TO CHECKRED :NUM
IF MEMBERP SUIT FIRST :STACK :REDS [STOP]
IF CARDBEFOREP (RANK :CARD) (RANK FIRST :STACK) ~
   [PUSH (LIST "PLAYONTO :NUM) "ONTO]
END

TO CHECKTOP
IF EQUALP RANK :CARD "A ~
   [IF EMPTYP TOP SUIT :CARD ~
       [PUSH (LIST "PLAYTOP WORD "" SUIT :CARD) "ONTO] ~
    STOP]
IF CARDBEFOREP (TOP SUIT :CARD) (RANK :CARD) ~
   [PUSH (LIST "PLAYTOP WORD "" SUIT :CARD) "ONTO]
END

TO COVEREDP
IF EQUALP :WHERE [REMPILE] [OUTPUT "FALSE]
OUTPUT NOT EQUALP :CARD FIRST THING SHOWN LAST :WHERE
END

TO DEAL
IF EMPTYP :HAND [MAKE "HAND :PILE SETEMPTY "PILE]
IF EMPTYP :HAND [OUTPUT []]
OUTPUT SPOP "HAND
END

TO DECK
OP MAKESUITS (SE :HEART :SPADE :DIAMOND :CLUB)
END

TO DISHAND
SETCURSOR [27 23]
TYPE COUNT :HAND
TYPE "| |
END

TO DISPILE
SETCURSOR [32 23]
IFELSE EMPTYP :PILE [SPACES 3] [CARDDIS LAST :PILE]
END

TO DISSTACK :NUM
SETCURSOR LIST INT (-3+5*:NUM) 4
TYPE IFELSE STACKEMPTYP HIDDEN :NUM ["| |] ["-]
IF STACKEMPTYP SHOWN :NUM ~
   [SETCURSOR LIST INT (-4+5*:NUM) 5 SPACES 3 STOP]
DISSTACK1 :NUM (THING SHOWN :NUM)
END

TO DISSTACK1 :NUM :STACK
DISSTACK2 (4+COUNT :STACK) INT (-4+5*:NUM) :STACK
END

TO DISSTACK2 :ROW :COL :STACK
IF EMPTYP :STACK [STOP]
SETCURSOR LIST :COL :ROW
CARDDIS FIRST :STACK
DISSTACK2 :ROW-1 :COL BF :STACK
END

TO DISSTACKS :NUM
IF :NUM = 0 [STOP]
DISSTACK :NUM
DISSTACKS :NUM-1
END

TO DISTOP :SUIT
IF EMPTYP TOP :SUIT [STOP]
IF EQUALP :SUIT :HEART [DISTOP1 4 STOP]
IF EQUALP :SUIT :SPADE [DISTOP1 11 STOP]
IF EQUALP :SUIT :DIAMOND [DISTOP1 18 STOP]
DISTOP1 25
END

TO DISTOP1 :COL
SETCURSOR LIST :COL 2
CARDDIS WORD (TOP :SUIT) :SUIT
END

TO FINDCARD
IF FINDPILE [STOP]
MAKE "WHERE FINDSHOWN 7
IF EMPTYP :WHERE [BELL]
END

TO FINDPILE
IF EMPTYP :PILE [OUTPUT "FALSE]
IF EQUALP :CARD LAST :PILE [MAKE "WHERE [REMPILE] OUTPUT "TRUE]
OUTPUT "FALSE
END

TO FINDSHOWN :NUM
IF :NUM = 0 [OUTPUT []]
IF MEMBERP :CARD THING SHOWN :NUM [OP SE "REMSHOWN :NUM]
OP FINDSHOWN :NUM-1
END

TO HAND3
IF NOT EMPTYP :DIGIT [BELL STOP]
IF AND EMPTYP :HAND EMPTYP :PILE [BELL STOP]
LPUSH DEAL "PILE
REPEAT 2 [IF NOT EMPTYP :HAND [LPUSH DEAL "PILE]]
DISPILE
DISHAND
END

TO SHELP
CT
INSTRUCT
SPBPR 0 [TYPE ANY KEY TO CONTINUE]
IGNORE RC
REDISPLAY
END

TO HIDDEN :NUM
OUTPUT WORD "HIDDEN :NUM
END

TO INITHIDDEN :NUM
SETEMPTY HIDDEN :NUM
REPEAT :NUM [PUSH DEAL HIDDEN :NUM]
END

TO INITSTACKS :NUM
IF :NUM = 0 [STOP]
INITHIDDEN :NUM
TURNUP :NUM
INITSTACKS :NUM-1
END

TO INSTRUCT
PR [WELCOME TO SOLITAIRE]
PR []
PR [HERE ARE THE COMMANDS YOU CAN TYPE:]
SPBTYPE 4 "+ SPPR 4 [DEAL THREE CARDS ONTO PILE]
SPBTYPE 4 "P SPPR 4 [PLAY TOP CARD FROM PILE]
SPBTYPE 4 "R SPPR 4 [REDISPLAY THE BOARD]
SPBTYPE 4 "? SPPR 4 [RETYPE THESE INSTRUCTIONS]
SPBTYPE 4 "CARD SPPR 1 [PLAY THAT CARD]
PR []
PR [A CARD CONSISTS OF A RANK:]
SPBPR 3 [A 2 3 4 5 6 7 8 9 10 J Q K]
PR [FOLLOWED BY A SUIT:]
SPBPR 3 [H S D C]
PR []
PR [IF YOU MAKE A MISTAKE,]
SPPR 3 [HIT THE SPACE BAR.]
PR []
PR [TO MOVE AN ENTIRE STACK,]
SPPR 3 [HIT THE SHIFTED STACK NUMBER:]
SPBTYPE 5 [! @ # $ % ^ &] SPPR 1 [FOR STACKS]
SPPR 5 [1 2 3 4 5 6 7]
PR []
END

TO INVTYPE :TEXT
TYPE STANDOUT :TEXT
END

TO LOOP
IF EMPTYP :DIGIT [SETCURSOR [1 22] SPACES 6 SETCURSOR [1 22]]
PARSEKEY RC
LOOP
END

TO LPOP :STACK
LOCAL "RESULT
MAKE "RESULT LAST THING :STACK
MAKE :STACK BL THING :STACK
OUTPUT :RESULT
END

TO LPUSH :THING :STACK
MAKE :STACK LPUT :THING THING :STACK
END

TO MAKESUIT :SUIT :CARDS
IF EMPTYP :CARDS [OUTPUT []]
OUTPUT FPUT (WORD FIRST :CARDS :SUIT) MAKESUIT :SUIT BF :CARDS
END

TO MAKESUITS :LIST
IF EMPTYP :LIST [OUTPUT []]
OUTPUT SE MAKESUIT FIRST :LIST [A 2 3 4 5 6 7 8 9 10 J Q K] ~
          MAKESUITS BF :LIST
END

TO PARSEDIGIT :CHAR
IF NOT EMPTYP :DIGIT [BELL STOP]
MAKE "DIGIT :CHAR
TYPE :CHAR
END

TO PARSEKEY :CHAR
IF MEMBERP :CHAR [1 2 3 4 5 6 7 8 9 A J Q K] [PARSEDIGIT :CHAR STOP]
IF EQUALP :CHAR "0 [PARSEZERO STOP]
IF MEMBERP :CHAR [H S D C] [PARSESUIT :CHAR STOP]
IF MEMBERP :CHAR [+ =] [HAND3 STOP]
IF EQUALP :CHAR "R [REDISPLAY STOP]
IF EQUALP :CHAR "? [SHELP STOP]
IF EQUALP :CHAR "P [PLAYPILE STOP]
IF MEMBERP :CHAR [! @ # $ % ^ &] [PLAYSTACK :CHAR [! @ # $ % ^ &] STOP]
IF EQUALP :CHAR "| | [RUBOUT STOP]
IF EQUALP :CHAR "\( [CHEAT STOP]
BELL
END

TO PARSESUIT :CHAR
IF EMPTYP :DIGIT [BELL STOP]
IF EQUALP :DIGIT 1 [MAKE "DIGIT "A]
IF EQUALP :CHAR "H [MAKE "CHAR :HEART]
IF EQUALP :CHAR "S [MAKE "CHAR :SPADE]
IF EQUALP :CHAR "D [MAKE "CHAR :DIAMOND]
IF EQUALP :CHAR "C [MAKE "CHAR :CLUB]
TYPE :CHAR
MAKE "CARD WORD :DIGIT :CHAR
SETEMPTY "DIGIT
FINDCARD
IF NOT EMPTYP :WHERE [PLAYCARD]
END

TO PARSEZERO
IF NOT EQUALP :DIGIT 1 [BELL STOP]
MAKE "DIGIT 10
TYPE 0
END

TO PLAYCARD
SETEMPTY "ONTO
IF NOT COVEREDP [CHECKTOP]
CHECKONTO 7
IF EMPTYP :ONTO [BELL STOP]
IFELSE (COUNT :ONTO) > 1 [ASKWHICH] [MAKE "ONTO FIRST :ONTO]
RUN :WHERE
RUN :ONTO
SETEMPTY "DIGIT
END

TO PLAYONTO :NUM
IF EMPTYP :CARDS [DISSTACK :NUM STOP]
PUSH (SPOP "CARDS) SHOWN :NUM
PLAYONTO :NUM
END

TO PLAYPILE
IF EMPTYP :PILE [BELL STOP]
IF NOT EMPTYP :DIGIT [BELL STOP]
MAKE "CARD LAST :PILE
MAKE "WHERE [REMPILE]
CARDDIS :CARD
PLAYCARD
END

TO PLAYSTACK :WHICH :LIST
IF NOT EMPTYP :DIGIT [BELL STOP]
PLAYSTACK1 :WHICH :LIST 1
END

TO PLAYSTACK1 :WHICH :LIST :NUM
IF EQUALP :WHICH FIRST :LIST [PLAYSTACK2 :NUM STOP]
PLAYSTACK1 :WHICH BF :LIST :NUM+1
END

TO PLAYSTACK2 :NUM
IF STACKEMPTYP SHOWN :NUM [BELL STOP]
MAKE "CARD LAST THING SHOWN :NUM
MAKE "WHERE SE "REMSHOWN :NUM
CARDDIS :CARD
PLAYCARD
END

TO PLAYTOP :SUIT
SETTOP :SUIT RANK :CARD
DISTOP :SUIT
END

TO PUSH :THING :STACK
MAKE :STACK FPUT :THING THING :STACK
END

TO RANK :CARD
OUTPUT BL :CARD
END

TO REDISPLAY
CT
DISSTACKS 7
DISTOP :HEART
DISTOP :SPADE
DISTOP :DIAMOND
DISTOP :CLUB
DISPILE
DISHAND
SETCURSOR [1 22]
SETEMPTY "DIGIT
END

TO REDTYPE :WORD
TYPE :WORD
END

TO REMOVE :NUM :LIST
IF :NUM = 1 [OUTPUT BF :LIST]
OP FPUT FIRST :LIST REMOVE :NUM-1 BF :LIST
END

TO REMPILE
MAKE "CARDS (LIST (LPOP "PILE))
DISPILE
END

TO REMSHOWN :NUM
SETEMPTY "CARDS
REMSHOWN1 :NUM 1 (COUNT THING SHOWN :NUM)
IF STACKEMPTYP SHOWN :NUM [TURNUP :NUM DISSTACK :NUM]
END

TO REMSHOWN1 :NUM :DEPTH :LENGTH
PUSH (SPOP SHOWN :NUM) "CARDS
IF EQUALP :CARD FIRST :CARDS ~
   [REMSHOWN2 :DEPTH (5+:LENGTH-:DEPTH) INT (-4+5*:NUM) STOP]
REMSHOWN1 :NUM :DEPTH+1 :LENGTH
END

TO REMSHOWN2 :DEPTH :ROW :COL
IF :DEPTH = 0 [STOP]
SETCURSOR LIST :COL :ROW
SPACES 3
REMSHOWN2 :DEPTH-1 :ROW+1 :COL
END

TO RUBOUT
SETCURSOR [1 22]
SPACES 4
SETCURSOR [1 22]
SETEMPTY "DIGIT
END

TO SETEMPTY :STACK
MAKE :STACK []
END

TO SETTOP :SUIT :VALUE
MAKE (WORD "TOP :SUIT) :VALUE
END

TO SHOWN :NUM
OUTPUT WORD "SHOWN :NUM
END

TO SHUFFLE :LEN :LIST
LOCAL "NEW
SETEMPTY "NEW
REPEAT :LEN [SHUFFLE1 1+RANDOM :LEN]
OP :NEW
END

TO SHUFFLE1 :RAND
PUSH (ITEM :RAND :LIST) "NEW
MAKE "LIST REMOVE :RAND :LIST
MAKE "LEN :LEN-1
END

TO SOLITAIRE
INSTRUCT
PR [SHUFFLING, PLEASE WAIT...]
MAKE "HEART "H
MAKE "SPADE "S
MAKE "DIAMOND "D
MAKE "CLUB "C
MAKE "HAND SHUFFLE 52 DECK
SETEMPTY "PILE
INITSTACKS 7
MAKE "REDS LIST :HEART :DIAMOND
SETTOP :HEART "
SETTOP :SPADE "
SETTOP :DIAMOND "
SETTOP :CLUB "
REDISPLAY
LOOP
END

TO SPACES :NUM
REPEAT :NUM [TYPE "| |]
END

TO SPBPR :SPACES :TEXT
SPBTYPE :SPACES :TEXT
PR []
END

TO SPBTYPE :SPACES :TEXT
SPACES :SPACES
INVTYPE :TEXT
END

TO SPOP :STACK
LOCAL "RESULT
MAKE "RESULT FIRST THING :STACK
MAKE :STACK BF THING :STACK
OUTPUT :RESULT
END

TO SPPR :SPACES :TEXT
SPACES :SPACES
PR :TEXT
END

TO STACKEMPTYP :NAME
OUTPUT EMPTYP THING :NAME
END

TO SUIT :CARD
OUTPUT LAST :CARD
END

TO TOP :SUIT
OUTPUT THING WORD "TOP :SUIT
END

TO TURNUP :NUM
SETEMPTY SHOWN :NUM
IF STACKEMPTYP HIDDEN :NUM [STOP]
PUSH (SPOP HIDDEN :NUM) SHOWN :NUM
END